home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / lib / perl5 / XML / LibXML.pm next >
Encoding:
Perl POD Document  |  2009-10-29  |  61.4 KB  |  2,239 lines

  1. # $Id: LibXML.pm 809 2009-10-04 21:17:41Z pajas $
  2. #
  3. #
  4. # This is free software, you may use it and distribute it under the same terms as
  5. # Perl itself.
  6. #
  7. # Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
  8. #
  9. #
  10.  
  11. package XML::LibXML;
  12.  
  13. use strict;
  14. use vars qw($VERSION $ABI_VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS
  15.             $skipDTD $skipXMLDeclaration $setTagCompression
  16.             $MatchCB $ReadCB $OpenCB $CloseCB %PARSER_FLAGS
  17.             );
  18. use Carp;
  19.  
  20. use constant XML_XMLNS_NS => 'http://www.w3.org/2000/xmlns/';
  21. use constant XML_XML_NS => 'http://www.w3.org/XML/1998/namespace';
  22.  
  23. use XML::LibXML::Error;
  24. use XML::LibXML::NodeList;
  25. use XML::LibXML::XPathContext;
  26. use IO::Handle; # for FH reads called as methods
  27.  
  28. BEGIN {
  29. $VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
  30. $ABI_VERSION = 2;
  31. require Exporter;
  32. require DynaLoader;
  33. @ISA = qw(DynaLoader Exporter);
  34.  
  35. use vars qw($__PROXY_NODE_REGISTRY $__threads_shared $__PROXY_NODE_REGISTRY_MUTEX $__loaded);
  36.  
  37. sub VERSION {
  38.   my $class = shift;
  39.   my ($caller) = caller;
  40.   my $req_abi = $ABI_VERSION;
  41.   if (UNIVERSAL::can($caller,'REQUIRE_XML_LIBXML_ABI_VERSION')) {
  42.     $req_abi = $caller->REQUIRE_XML_LIBXML_ABI_VERSION();
  43.   } elsif ($caller eq 'XML::LibXSLT') {
  44.     # XML::LibXSLT without REQUIRE_XML_LIBXML_ABI_VERSION is an old and incompatible version
  45.     $req_abi = 1;
  46.   }
  47.   unless ($req_abi == $ABI_VERSION) {
  48.     my $ver = @_ ? ' '.$_[0] : '';
  49.     die ("This version of $caller requires XML::LibXML$ver (ABI $req_abi), which is incompatible with currently installed XML::LibXML $VERSION (ABI $ABI_VERSION). Please upgrade $caller, XML::LibXML, or both!");
  50.   }
  51.   return $class->UNIVERSAL::VERSION(@_)
  52. }
  53.  
  54. #-------------------------------------------------------------------------#
  55. # export information                                                      #
  56. #-------------------------------------------------------------------------#
  57. %EXPORT_TAGS = (
  58.                 all => [qw(
  59.                            XML_ELEMENT_NODE
  60.                            XML_ATTRIBUTE_NODE
  61.                            XML_TEXT_NODE
  62.                            XML_CDATA_SECTION_NODE
  63.                            XML_ENTITY_REF_NODE
  64.                            XML_ENTITY_NODE
  65.                            XML_PI_NODE
  66.                            XML_COMMENT_NODE
  67.                            XML_DOCUMENT_NODE
  68.                            XML_DOCUMENT_TYPE_NODE
  69.                            XML_DOCUMENT_FRAG_NODE
  70.                            XML_NOTATION_NODE
  71.                            XML_HTML_DOCUMENT_NODE
  72.                            XML_DTD_NODE
  73.                            XML_ELEMENT_DECL
  74.                            XML_ATTRIBUTE_DECL
  75.                            XML_ENTITY_DECL
  76.                            XML_NAMESPACE_DECL
  77.                            XML_XINCLUDE_END
  78.                            XML_XINCLUDE_START
  79.                            encodeToUTF8
  80.                            decodeFromUTF8
  81.                    XML_XMLNS_NS
  82.                    XML_XML_NS
  83.                           )],
  84.                 libxml => [qw(
  85.                            XML_ELEMENT_NODE
  86.                            XML_ATTRIBUTE_NODE
  87.                            XML_TEXT_NODE
  88.                            XML_CDATA_SECTION_NODE
  89.                            XML_ENTITY_REF_NODE
  90.                            XML_ENTITY_NODE
  91.                            XML_PI_NODE
  92.                            XML_COMMENT_NODE
  93.                            XML_DOCUMENT_NODE
  94.                            XML_DOCUMENT_TYPE_NODE
  95.                            XML_DOCUMENT_FRAG_NODE
  96.                            XML_NOTATION_NODE
  97.                            XML_HTML_DOCUMENT_NODE
  98.                            XML_DTD_NODE
  99.                            XML_ELEMENT_DECL
  100.                            XML_ATTRIBUTE_DECL
  101.                            XML_ENTITY_DECL
  102.                            XML_NAMESPACE_DECL
  103.                            XML_XINCLUDE_END
  104.                            XML_XINCLUDE_START
  105.                           )],
  106.                 encoding => [qw(
  107.                                 encodeToUTF8
  108.                                 decodeFromUTF8
  109.                                )],
  110.         ns => [qw(
  111.                    XML_XMLNS_NS
  112.                    XML_XML_NS
  113.          )],
  114.                );
  115.  
  116. @EXPORT_OK = (
  117.               @{$EXPORT_TAGS{all}},
  118.              );
  119.  
  120. @EXPORT = (
  121.            @{$EXPORT_TAGS{all}},
  122.           );
  123.  
  124. #-------------------------------------------------------------------------#
  125. # initialization of the global variables                                  #
  126. #-------------------------------------------------------------------------#
  127. $skipDTD            = 0;
  128. $skipXMLDeclaration = 0;
  129. $setTagCompression  = 0;
  130.  
  131. $MatchCB = undef;
  132. $ReadCB  = undef;
  133. $OpenCB  = undef;
  134. $CloseCB = undef;
  135.  
  136. # if ($threads::threads) {
  137. #   our $__THREADS_TID = 0;
  138. #   eval q{
  139. #     use threads::shared;
  140. #     our $__PROXY_NODE_REGISTRY_MUTEX :shared = 0;
  141. #   };
  142. #   die $@ if $@;
  143. # }
  144. #-------------------------------------------------------------------------#
  145. # bootstrapping                                                           #
  146. #-------------------------------------------------------------------------#
  147. bootstrap XML::LibXML $VERSION;
  148. undef &AUTOLOAD;
  149.  
  150. *encodeToUTF8 = \&XML::LibXML::Common::encodeToUTF8;
  151. *decodeFromUTF8 = \&XML::LibXML::Common::decodeFromUTF8;
  152.  
  153. } # BEGIN
  154.  
  155.  
  156. #-------------------------------------------------------------------------#
  157. # libxml2 node names (see also XML::LibXML::Common                        #
  158. #-------------------------------------------------------------------------#
  159. use constant XML_ELEMENT_NODE            => 1;
  160. use constant XML_ATTRIBUTE_NODE          => 2;
  161. use constant XML_TEXT_NODE               => 3;
  162. use constant XML_CDATA_SECTION_NODE      => 4;
  163. use constant XML_ENTITY_REF_NODE         => 5;
  164. use constant XML_ENTITY_NODE             => 6;
  165. use constant XML_PI_NODE                 => 7;
  166. use constant XML_COMMENT_NODE            => 8;
  167. use constant XML_DOCUMENT_NODE           => 9;
  168. use constant XML_DOCUMENT_TYPE_NODE      => 10;
  169. use constant XML_DOCUMENT_FRAG_NODE      => 11;
  170. use constant XML_NOTATION_NODE           => 12;
  171. use constant XML_HTML_DOCUMENT_NODE      => 13;
  172. use constant XML_DTD_NODE                => 14;
  173. use constant XML_ELEMENT_DECL            => 15;
  174. use constant XML_ATTRIBUTE_DECL          => 16;
  175. use constant XML_ENTITY_DECL             => 17;
  176. use constant XML_NAMESPACE_DECL          => 18;
  177. use constant XML_XINCLUDE_START          => 19;
  178. use constant XML_XINCLUDE_END            => 20;
  179.  
  180.  
  181. sub import {
  182.   my $package=shift;
  183.   if (grep /^:threads_shared$/, @_) {
  184.     require threads;
  185.     if (!defined($__threads_shared)) {
  186.       if (INIT_THREAD_SUPPORT()) {
  187.     eval q{
  188.           use threads::shared;
  189.           share($__PROXY_NODE_REGISTRY_MUTEX);
  190.         };
  191.     if ($@) { # something went wrong
  192.       DISABLE_THREAD_SUPPORT(); # leave the library in a usable state
  193.       die $@; # and die
  194.     }
  195.     $__PROXY_NODE_REGISTRY = XML::LibXML::HashTable->new();
  196.     $__threads_shared=1;
  197.       } else {
  198.     croak("XML::LibXML or Perl compiled without ithread support!");
  199.       }
  200.     } elsif (!$__threads_shared) {
  201.       croak("XML::LibXML already loaded without thread support. Too late to enable thread support!");
  202.     }
  203.   } elsif (defined $XML::LibXML::__loaded) {
  204.     $__threads_shared=0 if not defined $__threads_shared;
  205.   }
  206.   __PACKAGE__->export_to_level(1,$package,grep !/^:threads(_shared)?$/,@_);
  207. }
  208.  
  209. sub threads_shared_enabled {
  210.   return $__threads_shared ? 1 : 0;
  211. }
  212.  
  213. # if ($threads::threads) {
  214. #   our $__PROXY_NODE_REGISTRY = XML::LibXML::HashTable->new();
  215. # }
  216.  
  217. #-------------------------------------------------------------------------#
  218. # test exact version (up to patch-level)                                  #
  219. #-------------------------------------------------------------------------#
  220. {
  221.   my ($runtime_version) = LIBXML_RUNTIME_VERSION() =~ /^(\d+)/;
  222.   if ( $runtime_version < LIBXML_VERSION ) {
  223.     warn "Warning: XML::LibXML compiled against libxml2 ".LIBXML_VERSION.
  224.       ", but runtime libxml2 is older $runtime_version\n";
  225.   }
  226. }
  227.  
  228.  
  229. #-------------------------------------------------------------------------#
  230. # parser flags                                                            #
  231. #-------------------------------------------------------------------------#
  232.  
  233. # Copied directly from http://xmlsoft.org/html/libxml-parser.html#xmlParserOption
  234. use constant {
  235.   XML_PARSE_RECOVER      => 1,           # recover on errors
  236.   XML_PARSE_NOENT      => 2,           # substitute entities
  237.   XML_PARSE_DTDLOAD      => 4,           # load the external subset
  238.   XML_PARSE_DTDATTR      => 8,           # default DTD attributes
  239.   XML_PARSE_DTDVALID      => 16,       # validate with the DTD
  240.   XML_PARSE_NOERROR      => 32,       # suppress error reports
  241.   XML_PARSE_NOWARNING      => 64,       # suppress warning reports
  242.   XML_PARSE_PEDANTIC      => 128,      # pedantic error reporting
  243.   XML_PARSE_NOBLANKS      => 256,      # remove blank nodes
  244.   XML_PARSE_SAX1      => 512,      # use the SAX1 interface internally
  245.   XML_PARSE_XINCLUDE      => 1024,     # Implement XInclude substitition
  246.   XML_PARSE_NONET      => 2048,     # Forbid network access
  247.   XML_PARSE_NODICT      => 4096,     # Do not reuse the context dictionnary
  248.   XML_PARSE_NSCLEAN      => 8192,     # remove redundant namespaces declarations
  249.   XML_PARSE_NOCDATA      => 16384,    # merge CDATA as text nodes
  250.   XML_PARSE_NOXINCNODE      => 32768,    # do not generate XINCLUDE START/END nodes
  251.   XML_PARSE_COMPACT      => 65536,    # compact small text nodes; no modification of the tree allowed afterwards
  252.                                        # (will possibly crash if you try to modify the tree)
  253.   XML_PARSE_OLD10      => 131072,   # parse using XML-1.0 before update 5
  254.   XML_PARSE_NOBASEFIX      => 262144,   # do not fixup XINCLUDE xml#base uris
  255.   XML_PARSE_HUGE      => 524288,   # relax any hardcoded limit from the parser
  256.   XML_PARSE_OLDSAX      => 1048576,  # parse using SAX2 interface from before 2.7.0
  257. };
  258.  
  259. use constant XML_LIBXML_PARSE_DEFAULTS => ( XML_PARSE_NODICT | XML_PARSE_HUGE | XML_PARSE_DTDLOAD | XML_PARSE_NOENT );
  260.  
  261. # this hash is made global so that applications can add names for new
  262. # libxml2 parser flags as temporary workaround
  263.  
  264. %PARSER_FLAGS = (
  265.   recover         => XML_PARSE_RECOVER,
  266.   expand_entities     => XML_PARSE_NOENT,
  267.   load_ext_dtd             => XML_PARSE_DTDLOAD,
  268.   complete_attributes     => XML_PARSE_DTDATTR,
  269.   validation         => XML_PARSE_DTDVALID,
  270.   suppress_errors     => XML_PARSE_NOERROR,
  271.   suppress_warnings     => XML_PARSE_NOWARNING,
  272.   pedantic_parser     => XML_PARSE_PEDANTIC,
  273.   no_blanks         => XML_PARSE_NOBLANKS,
  274.   expand_xinclude     => XML_PARSE_XINCLUDE,
  275.   xinclude         => XML_PARSE_XINCLUDE,
  276.   no_network         => XML_PARSE_NONET,
  277.   clean_namespaces     => XML_PARSE_NSCLEAN,
  278.   no_cdata         => XML_PARSE_NOCDATA,
  279.   no_xinclude_nodes     => XML_PARSE_NOXINCNODE,
  280.   old10                 => XML_PARSE_OLD10,
  281.   no_base_fix         => XML_PARSE_NOBASEFIX,
  282.   huge                 => XML_PARSE_HUGE,
  283.   oldsax         => XML_PARSE_OLDSAX,
  284. );
  285.  
  286. my %OUR_FLAGS = (
  287.   recover => 'XML_LIBXML_RECOVER',
  288.   line_numbers => 'XML_LIBXML_LINENUMBERS',
  289.   URI => 'XML_LIBXML_BASE_URI',
  290.   base_uri => 'XML_LIBXML_BASE_URI',
  291.   gdome => 'XML_LIBXML_GDOME',
  292.   ext_ent_handler => 'ext_ent_handler',
  293. );
  294.  
  295. sub _parser_options {
  296.   my ($self, $opts) = @_;
  297.  
  298.   # currently dictionaries break XML::LibXML memory management
  299.  
  300.   my $flags;
  301.  
  302.   if (ref($self)) {
  303.     $flags = ($self->{XML_LIBXML_PARSER_OPTIONS}||0);
  304.   } else {
  305.     $flags = XML_LIBXML_PARSE_DEFAULTS;        # safety precaution
  306.   }
  307.  
  308.   my ($key, $value);
  309.   while (($key,$value) = each %$opts) {
  310.     my $f = $PARSER_FLAGS{ $key };
  311.     if (defined $f) {
  312.       if ($value) {
  313.     $flags |= $f
  314.       } else {
  315.     $flags &= ~$f;
  316.       }
  317.     } elsif ($key eq 'set_parser_flags') { # this can be used to pass flags XML::LibXML does not yet know about
  318.       $flags |= $value;
  319.     } elsif ($key eq 'unset_parser_flags') {
  320.       $flags &= ~$value;
  321.     }
  322.  
  323.   }
  324.   return $flags;
  325. }
  326.  
  327. my %compatibility_flags = (
  328.   XML_LIBXML_VALIDATION => 'validation',
  329.   XML_LIBXML_EXPAND_ENTITIES => 'expand_entities',
  330.   XML_LIBXML_PEDANTIC => 'pedantic_parser',
  331.   XML_LIBXML_NONET => 'no_network',
  332.   XML_LIBXML_EXT_DTD => 'load_ext_dtd',
  333.   XML_LIBXML_COMPLETE_ATTR => 'complete_attributes',
  334.   XML_LIBXML_EXPAND_XINCLUDE => 'expand_xinclude',
  335.   XML_LIBXML_NSCLEAN => 'clean_namespaces',
  336.   XML_LIBXML_KEEP_BLANKS => 'keep_blanks',
  337.   XML_LIBXML_LINENUMBERS => 'line_numbers',
  338. );
  339.  
  340. #-------------------------------------------------------------------------#
  341. # parser constructor                                                      #
  342. #-------------------------------------------------------------------------#
  343.  
  344.  
  345. sub new {
  346.     my $class = shift;
  347.     my $self = bless {
  348.     }, $class;
  349.     if (@_) {
  350.       my %opts = ();
  351.       if (ref($_[0]) eq 'HASH') {
  352.     %opts = %{$_[0]};
  353.       } else {
  354.     # old interface
  355.     my %args = @_;
  356.     %opts=(
  357.       map {
  358.         (($compatibility_flags{ $_ }||$_) => $args{ $_ })
  359.       } keys %args
  360.     );
  361.       }
  362.       # parser flags
  363.       $opts{no_blanks} = !$opts{keep_blanks} if exists($opts{keep_blanks}) and !exists($opts{no_blanks});
  364.  
  365.       for (keys %OUR_FLAGS) {
  366.     $self->{$OUR_FLAGS{$_}} = delete $opts{$_};
  367.       }
  368.       $class->load_catalog(delete($opts{catalog})) if $opts{catalog};
  369.  
  370.       $self->{XML_LIBXML_PARSER_OPTIONS} = XML::LibXML->_parser_options(\%opts);
  371.  
  372.       # store remaining unknown options directly in $self
  373.       for (keys %opts) {
  374.     $self->{$_}=$opts{$_} unless exists $PARSER_FLAGS{$_};
  375.       }
  376.     } else {
  377.       $self->{XML_LIBXML_PARSER_OPTIONS} = XML_LIBXML_PARSE_DEFAULTS;
  378.     }
  379.     if ( defined $self->{Handler} ) {
  380.       $self->set_handler( $self->{Handler} );
  381.     }
  382.  
  383.     $self->{_State_} = 0;
  384.     return $self;
  385. }
  386.  
  387. sub _clone {
  388.   my ($self)=@_;
  389.   my $new = ref($self)->new({
  390.       recover => $self->{XML_LIBXML_RECOVER},
  391.       line_nubers => $self->{XML_LIBXML_LINENUMBERS},
  392.       base_uri => $self->{XML_LIBXML_BASE_URI},
  393.       gdome => $self->{XML_LIBXML_GDOME},
  394.       set_parser_flags => $self->{XML_LIBXML_PARSER_OPTIONS},
  395.     });
  396.   return $new;
  397. }
  398.  
  399. #-------------------------------------------------------------------------#
  400. # Threads support methods                                                 #
  401. #-------------------------------------------------------------------------#
  402.  
  403. # threads doc says CLONE's API may change in future, which would break
  404. # an XS method prototype
  405. sub CLONE {
  406.   if ($XML::LibXML::__threads_shared) {
  407.     XML::LibXML::_CLONE( $_[0] );
  408.   }
  409. }
  410.  
  411. sub CLONE_SKIP {
  412.   return $XML::LibXML::__threads_shared ? 0 : 1;
  413. }
  414.  
  415. sub __proxy_registry {
  416.   my ($class)=caller;
  417.   die "This version of $class uses API of XML::LibXML 1.66 which is not compatible with XML::LibXML $VERSION. Please upgrade $class!\n";
  418. }
  419.  
  420. #-------------------------------------------------------------------------#
  421. # DOM Level 2 document constructor                                        #
  422. #-------------------------------------------------------------------------#
  423.  
  424. sub createDocument {
  425.    my $self = shift;
  426.    if (!@_ or $_[0] =~ m/^\d\.\d$/) {
  427.      # for backward compatibility
  428.      return XML::LibXML::Document->new(@_);
  429.    }
  430.    else {
  431.      # DOM API: createDocument(namespaceURI, qualifiedName, doctype?)
  432.      my $doc = XML::LibXML::Document-> new;
  433.      my $el = $doc->createElementNS(shift, shift);
  434.      $doc->setDocumentElement($el);
  435.      $doc->setExternalSubset(shift) if @_;
  436.      return $doc;
  437.    }
  438. }
  439.  
  440. #-------------------------------------------------------------------------#
  441. # callback functions                                                      #
  442. #-------------------------------------------------------------------------#
  443.  
  444. sub input_callbacks {
  445.     my $self     = shift;
  446.     my $icbclass = shift;
  447.  
  448.     if ( defined $icbclass ) {
  449.         $self->{XML_LIBXML_CALLBACK_STACK} = $icbclass;
  450.     }
  451.     return $self->{XML_LIBXML_CALLBACK_STACK};
  452. }
  453.  
  454. sub match_callback {
  455.     my $self = shift;
  456.     if ( ref $self ) {
  457.         if ( scalar @_ ) {
  458.             $self->{XML_LIBXML_MATCH_CB} = shift;
  459.             $self->{XML_LIBXML_CALLBACK_STACK} = undef;
  460.         }
  461.         return $self->{XML_LIBXML_MATCH_CB};
  462.     }
  463.     else {
  464.         $MatchCB = shift if scalar @_;
  465.         return $MatchCB;
  466.     }
  467. }
  468.  
  469. sub read_callback {
  470.     my $self = shift;
  471.     if ( ref $self ) {
  472.         if ( scalar @_ ) {
  473.             $self->{XML_LIBXML_READ_CB} = shift;
  474.             $self->{XML_LIBXML_CALLBACK_STACK} = undef;
  475.         }
  476.         return $self->{XML_LIBXML_READ_CB};
  477.     }
  478.     else {
  479.         $ReadCB = shift if scalar @_;
  480.         return $ReadCB;
  481.     }
  482. }
  483.  
  484. sub close_callback {
  485.     my $self = shift;
  486.     if ( ref $self ) {
  487.         if ( scalar @_ ) {
  488.             $self->{XML_LIBXML_CLOSE_CB} = shift;
  489.             $self->{XML_LIBXML_CALLBACK_STACK} = undef;
  490.         }
  491.         return $self->{XML_LIBXML_CLOSE_CB};
  492.     }
  493.     else {
  494.         $CloseCB = shift if scalar @_;
  495.         return $CloseCB;
  496.     }
  497. }
  498.  
  499. sub open_callback {
  500.     my $self = shift;
  501.     if ( ref $self ) {
  502.         if ( scalar @_ ) {
  503.             $self->{XML_LIBXML_OPEN_CB} = shift;
  504.             $self->{XML_LIBXML_CALLBACK_STACK} = undef;
  505.         }
  506.         return $self->{XML_LIBXML_OPEN_CB};
  507.     }
  508.     else {
  509.         $OpenCB = shift if scalar @_;
  510.         return $OpenCB;
  511.     }
  512. }
  513.  
  514. sub callbacks {
  515.     my $self = shift;
  516.     if ( ref $self ) {
  517.         if (@_) {
  518.             my ($match, $open, $read, $close) = @_;
  519.             @{$self}{qw(XML_LIBXML_MATCH_CB XML_LIBXML_OPEN_CB XML_LIBXML_READ_CB XML_LIBXML_CLOSE_CB)} = ($match, $open, $read, $close);
  520.             $self->{XML_LIBXML_CALLBACK_STACK} = undef;
  521.         }
  522.         else {
  523.             return @{$self}{qw(XML_LIBXML_MATCH_CB XML_LIBXML_OPEN_CB XML_LIBXML_READ_CB XML_LIBXML_CLOSE_CB)};
  524.         }
  525.     }
  526.     else {
  527.         if (@_) {
  528.            ( $MatchCB, $OpenCB, $ReadCB, $CloseCB ) = @_;
  529.         }
  530.         else {
  531.             return ( $MatchCB, $OpenCB, $ReadCB, $CloseCB );
  532.         }
  533.     }
  534. }
  535.  
  536. #-------------------------------------------------------------------------#
  537. # internal member variable manipulation                                   #
  538. #-------------------------------------------------------------------------#
  539. sub __parser_option {
  540.   my ($self, $opt) = @_;
  541.   if (@_>2) {
  542.     if ($_[2]) {
  543.       $self->{XML_LIBXML_PARSER_OPTIONS} |= $opt;
  544.       return 1;
  545.     } else {
  546.       $self->{XML_LIBXML_PARSER_OPTIONS} &= ~$opt;
  547.       return 0;
  548.     }
  549.   } else {
  550.     return ($self->{XML_LIBXML_PARSER_OPTIONS} & $opt) ? 1 : 0;
  551.   }
  552. }
  553.  
  554. sub option_exists {
  555.     my ($self,$name)=@_;
  556.     return ($PARSER_FLAGS{$name} || $OUR_FLAGS{$name}) ? 1 : 0;
  557. }
  558. sub get_option {
  559.     my ($self,$name)=@_;
  560.     my $flag = $OUR_FLAGS{$name};
  561.     return $self->{$flag} if $flag;
  562.     $flag = $PARSER_FLAGS{$name};
  563.     return $self->__parser_option($flag) if $flag;
  564.     warn "XML::LibXML::get_option: unknown parser option $name\n";
  565.     return undef;
  566. }
  567. sub set_option {
  568.     my ($self,$name,$value)=@_;
  569.     my $flag = $OUR_FLAGS{$name};
  570.     return ($self->{$flag}=$value) if $flag;
  571.     $flag = $PARSER_FLAGS{$name};
  572.     return $self->__parser_option($flag,$value) if $flag;
  573.     warn "XML::LibXML::get_option: unknown parser option $name\n";
  574.     return undef;
  575. }
  576. sub set_options {
  577.   my $self=shift;
  578.   my $opts;
  579.   if (@_==1 and ref($_[0]) eq 'HASH') {
  580.     $opts = $_[0];
  581.   } elsif (@_ % 2 == 0) {
  582.     $opts={@_};
  583.   } else {
  584.     croak("Odd number of elements passed to set_options");
  585.   }
  586.   $self->set_option($_=>$opts->{$_}) foreach keys %$opts;
  587.   return;
  588. }
  589.  
  590. sub validation {
  591.     my $self = shift;
  592.     return $self->__parser_option(XML_PARSE_DTDVALID,@_);
  593. }
  594.  
  595. sub recover {
  596.     my $self = shift;
  597.     if (scalar @_) {
  598.       $self->{XML_LIBXML_RECOVER} = $_[0];
  599.       $self->__parser_option(XML_PARSE_RECOVER,@_);
  600.     }
  601.     return $self->{XML_LIBXML_RECOVER};
  602. }
  603.  
  604. sub recover_silently {
  605.     my $self = shift;
  606.     my $arg = shift;
  607.     (($arg == 1) ? $self->recover(2) : $self->recover($arg)) if defined($arg);
  608.     return (($self->recover()||0) == 2) ? 1 : 0;
  609. }
  610.  
  611. sub expand_entities {
  612.     my $self = shift;
  613.     if (scalar(@_) and $_[0]) {
  614.       return $self->__parser_option(XML_PARSE_NOENT | XML_PARSE_DTDLOAD,1);
  615.     }
  616.     return $self->__parser_option(XML_PARSE_NOENT,@_);
  617. }
  618.  
  619. sub keep_blanks {
  620.     my $self = shift;
  621.     my @args; # we have to negate the argument and return negated value, since
  622.               # the actual flag is no_blanks
  623.     if (scalar @_) {
  624.       @args=($_[0] ? 0 : 1);
  625.     }
  626.     return $self->__parser_option(XML_PARSE_NOBLANKS,@args) ? 0 : 1;
  627. }
  628.  
  629. sub pedantic_parser {
  630.     my $self = shift;
  631.     return $self->__parser_option(XML_PARSE_PEDANTIC,@_);
  632. }
  633.  
  634. sub line_numbers {
  635.     my $self = shift;
  636.     $self->{XML_LIBXML_LINENUMBERS} = shift if scalar @_;
  637.     return $self->{XML_LIBXML_LINENUMBERS};
  638. }
  639.  
  640. sub no_network {
  641.     my $self = shift;
  642.     return $self->__parser_option(XML_PARSE_NONET,@_);
  643. }
  644.  
  645. sub load_ext_dtd {
  646.     my $self = shift;
  647.     return $self->__parser_option(XML_PARSE_DTDLOAD,@_);
  648. }
  649.  
  650. sub complete_attributes {
  651.     my $self = shift;
  652.     return $self->__parser_option(XML_PARSE_DTDATTR,@_);
  653. }
  654.  
  655. sub expand_xinclude  {
  656.     my $self = shift;
  657.     return $self->__parser_option(XML_PARSE_XINCLUDE,@_);
  658. }
  659.  
  660. sub base_uri {
  661.     my $self = shift;
  662.     $self->{XML_LIBXML_BASE_URI} = shift if scalar @_;
  663.     return $self->{XML_LIBXML_BASE_URI};
  664. }
  665.  
  666. sub gdome_dom {
  667.     my $self = shift;
  668.     $self->{XML_LIBXML_GDOME} = shift if scalar @_;
  669.     return $self->{XML_LIBXML_GDOME};
  670. }
  671.  
  672. sub clean_namespaces {
  673.     my $self = shift;
  674.     return $self->__parser_option(XML_PARSE_NSCLEAN,@_);
  675. }
  676.  
  677. #-------------------------------------------------------------------------#
  678. # set the optional SAX(2) handler                                         #
  679. #-------------------------------------------------------------------------#
  680. sub set_handler {
  681.     my $self = shift;
  682.     if ( defined $_[0] ) {
  683.         $self->{HANDLER} = $_[0];
  684.  
  685.         $self->{SAX_ELSTACK} = [];
  686.         $self->{SAX} = {State => 0};
  687.     }
  688.     else {
  689.         # undef SAX handling
  690.         $self->{SAX_ELSTACK} = [];
  691.         delete $self->{HANDLER};
  692.         delete $self->{SAX};
  693.     }
  694. }
  695.  
  696. #-------------------------------------------------------------------------#
  697. # helper functions                                                        #
  698. #-------------------------------------------------------------------------#
  699. sub _auto_expand {
  700.     my ( $self, $result, $uri ) = @_;
  701.  
  702.     $result->setBaseURI( $uri ) if defined $uri;
  703.  
  704.     if ( $self->expand_xinclude ) {
  705.         $self->{_State_} = 1;
  706.         eval { $self->processXIncludes($result); };
  707.         my $err = $@;
  708.         $self->{_State_} = 0;
  709.         if ($err) {
  710.             $self->_cleanup_callbacks();
  711.             $result = undef;
  712.             croak $err;
  713.         }
  714.     }
  715.     return $result;
  716. }
  717.  
  718. sub _init_callbacks {
  719.     my $self = shift;
  720.     my $icb = $self->{XML_LIBXML_CALLBACK_STACK};
  721.     unless ( defined $icb ) {
  722.         $self->{XML_LIBXML_CALLBACK_STACK} = XML::LibXML::InputCallback->new();
  723.         $icb = $self->{XML_LIBXML_CALLBACK_STACK};
  724.     }
  725.  
  726.     my $mcb = $self->match_callback();
  727.     my $ocb = $self->open_callback();
  728.     my $rcb = $self->read_callback();
  729.     my $ccb = $self->close_callback();
  730.  
  731.     if ( defined $mcb and defined $ocb and defined $rcb and defined $ccb ) {
  732.         $icb->register_callbacks( [$mcb, $ocb, $rcb, $ccb] );
  733.     }
  734.     $icb->init_callbacks();
  735. }
  736.  
  737. sub _cleanup_callbacks {
  738.     my $self = shift;
  739.     $self->{XML_LIBXML_CALLBACK_STACK}->cleanup_callbacks();
  740.     my $mcb = $self->match_callback();
  741.     $self->{XML_LIBXML_CALLBACK_STACK}->unregister_callbacks( [$mcb] );
  742. }
  743.  
  744. sub __read {
  745.     read($_[0], $_[1], $_[2]);
  746. }
  747.  
  748. sub __write {
  749.     if ( ref( $_[0] ) ) {
  750.         $_[0]->write( $_[1], $_[2] );
  751.     }
  752.     else {
  753.         $_[0]->write( $_[1] );
  754.     }
  755. }
  756.  
  757. sub load_xml {
  758.   my ($class_or_self) = shift;
  759.   my %args = map { ref($_) eq 'HASH' ? (%$_) : $_ } @_;
  760.   my $URI = delete($args{URI});
  761.   $URI = "$URI"  if defined $URI; # stringify in case it is an URI object
  762.   my $parser;
  763.   if (ref($class_or_self)) {
  764.     $parser = $class_or_self->_clone();
  765.     $parser->{XML_LIBXML_PARSER_OPTIONS} = $parser->_parser_options(\%args);
  766.   } else {
  767.     $parser = $class_or_self->new(\%args);
  768.   }
  769.   my $dom;
  770.   if ( defined $args{location} ) {
  771.     $dom = $parser->parse_file( "$args{location}" );
  772.   }
  773.   elsif ( defined $args{string} ) {
  774.     $dom = $parser->parse_string( $args{string}, $URI );
  775.   }
  776.   elsif ( defined $args{IO} ) {
  777.     $dom = $parser->parse_fh( $args{IO}, $URI );
  778.   }
  779.   else {
  780.     croak("XML::LibXML->load: specify location, string, or IO");
  781.   }
  782.   return $dom;
  783. }
  784.  
  785. sub load_html {
  786.   my ($class_or_self) = shift;
  787.   my %args = map { ref($_) eq 'HASH' ? (%$_) : $_ } @_;
  788.   my $URI = delete($args{URI});
  789.   $URI = "$URI"  if defined $URI; # stringify in case it is an URI object
  790.   my $parser;
  791.   if (ref($class_or_self)) {
  792.     $parser = $class_or_self->_clone();
  793.   } else {
  794.     $parser = $class_or_self->new();
  795.   }
  796.   my $dom;
  797.   if ( defined $args{location} ) {
  798.     $dom = $parser->parse_html_file( "$args{location}", \%args );
  799.   }
  800.   elsif ( defined $args{string} ) {
  801.     $dom = $parser->parse_html_string( $args{string}, \%args );
  802.   }
  803.   elsif ( defined $args{IO} ) {
  804.     $dom = $parser->parse_html_fh( $args{IO}, \%args );
  805.   }
  806.   else {
  807.     croak("XML::LibXML->load: specify location, string, or IO");
  808.   }
  809.   return $dom;
  810. }
  811.  
  812. #-------------------------------------------------------------------------#
  813. # parsing functions                                                       #
  814. #-------------------------------------------------------------------------#
  815. # all parsing functions handle normal as SAX parsing at the same time.
  816. # note that SAX parsing is handled incomplete! use XML::LibXML::SAX for
  817. # complete parsing sequences
  818. #-------------------------------------------------------------------------#
  819. sub parse_string {
  820.     my $self = shift;
  821.     croak("parse_string is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
  822.     croak("parse already in progress") if $self->{_State_};
  823.  
  824.     unless ( defined $_[0] and length $_[0] ) {
  825.         croak("Empty String");
  826.     }
  827.  
  828.     $self->{_State_} = 1;
  829.     my $result;
  830.  
  831.     $self->_init_callbacks();
  832.  
  833.     if ( defined $self->{SAX} ) {
  834.         my $string = shift;
  835.         $self->{SAX_ELSTACK} = [];
  836.         eval { $result = $self->_parse_sax_string($string); };
  837.         my $err = $@;
  838.         $self->{_State_} = 0;
  839.         if ($err) {
  840.         chomp $err unless ref $err;
  841.             $self->_cleanup_callbacks();
  842.             croak $err;
  843.         }
  844.     }
  845.     else {
  846.         eval { $result = $self->_parse_string( @_ ); };
  847.  
  848.         my $err = $@;
  849.         $self->{_State_} = 0;
  850.         if ($err) {
  851.         chomp $err unless ref $err;
  852.             $self->_cleanup_callbacks();
  853.             croak $err;
  854.         }
  855.  
  856.         $result = $self->_auto_expand( $result, $self->{XML_LIBXML_BASE_URI} );
  857.     }
  858.     $self->_cleanup_callbacks();
  859.  
  860.     return $result;
  861. }
  862.  
  863. sub parse_fh {
  864.     my $self = shift;
  865.     croak("parse_fh is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
  866.     croak("parse already in progress") if $self->{_State_};
  867.     $self->{_State_} = 1;
  868.     my $result;
  869.  
  870.     $self->_init_callbacks();
  871.  
  872.     if ( defined $self->{SAX} ) {
  873.         $self->{SAX_ELSTACK} = [];
  874.         eval { $self->_parse_sax_fh( @_ );  };
  875.         my $err = $@;
  876.         $self->{_State_} = 0;
  877.         if ($err) {
  878.         chomp $err unless ref $err;
  879.             $self->_cleanup_callbacks();
  880.             croak $err;
  881.         }
  882.     }
  883.     else {
  884.         eval { $result = $self->_parse_fh( @_ ); };
  885.         my $err = $@;
  886.         $self->{_State_} = 0;
  887.         if ($err) {
  888.         chomp $err unless ref $err;
  889.             $self->_cleanup_callbacks();
  890.             croak $err;
  891.         }
  892.  
  893.         $result = $self->_auto_expand( $result, $self->{XML_LIBXML_BASE_URI} );
  894.     }
  895.  
  896.     $self->_cleanup_callbacks();
  897.  
  898.     return $result;
  899. }
  900.  
  901. sub parse_file {
  902.     my $self = shift;
  903.     croak("parse_file is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
  904.     croak("parse already in progress") if $self->{_State_};
  905.  
  906.     $self->{_State_} = 1;
  907.     my $result;
  908.  
  909.     $self->_init_callbacks();
  910.  
  911.     if ( defined $self->{SAX} ) {
  912.         $self->{SAX_ELSTACK} = [];
  913.         eval { $self->_parse_sax_file( @_ );  };
  914.         my $err = $@;
  915.         $self->{_State_} = 0;
  916.         if ($err) {
  917.         chomp $err unless ref $err;
  918.             $self->_cleanup_callbacks();
  919.             croak $err;
  920.         }
  921.     }
  922.     else {
  923.         eval { $result = $self->_parse_file(@_); };
  924.         my $err = $@;
  925.         $self->{_State_} = 0;
  926.         if ($err) {
  927.         chomp $err unless ref $err;
  928.             $self->_cleanup_callbacks();
  929.             croak $err;
  930.         }
  931.  
  932.         $result = $self->_auto_expand( $result );
  933.     }
  934.     $self->_cleanup_callbacks();
  935.  
  936.     return $result;
  937. }
  938.  
  939. sub parse_xml_chunk {
  940.     my $self = shift;
  941.     # max 2 parameter:
  942.     # 1: the chunk
  943.     # 2: the encoding of the string
  944.     croak("parse_xml_chunk is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
  945.     croak("parse already in progress") if $self->{_State_};    my $result;
  946.  
  947.     unless ( defined $_[0] and length $_[0] ) {
  948.         croak("Empty String");
  949.     }
  950.  
  951.     $self->{_State_} = 1;
  952.  
  953.     $self->_init_callbacks();
  954.  
  955.     if ( defined $self->{SAX} ) {
  956.         eval {
  957.             $self->_parse_sax_xml_chunk( @_ );
  958.  
  959.             # this is required for XML::GenericChunk.
  960.             # in normal case is_filter is not defined, an thus the parsing
  961.             # will be terminated. in case of a SAX filter the parsing is not
  962.             # finished at that state. therefore we must not reset the parsing
  963.             unless ( $self->{IS_FILTER} ) {
  964.           $result = $self->{HANDLER}->end_document();
  965.         }
  966.         };
  967.     }
  968.     else {
  969.         eval { $result = $self->_parse_xml_chunk( @_ ); };
  970.     }
  971.  
  972.     $self->_cleanup_callbacks();
  973.  
  974.     my $err = $@;
  975.     $self->{_State_} = 0;
  976.     if ($err) {
  977.         chomp $err unless ref $err;
  978.         croak $err;
  979.     }
  980.  
  981.     return $result;
  982. }
  983.  
  984. sub parse_balanced_chunk {
  985.     my $self = shift;
  986.     $self->_init_callbacks();
  987.     my $rv;
  988.     eval {
  989.         $rv = $self->parse_xml_chunk( @_ );
  990.     };
  991.     my $err = $@;
  992.     $self->_cleanup_callbacks();
  993.     if ( $err ) {
  994.         chomp $err unless ref $err;
  995.         croak $err;
  996.     }
  997.     return $rv
  998. }
  999.  
  1000. # java style
  1001. sub processXIncludes {
  1002.     my $self = shift;
  1003.     my $doc = shift;
  1004.     my $opts = shift;
  1005.     my $options = $self->_parser_options($opts);
  1006.     if ( $self->{_State_} != 1 ) {
  1007.         $self->_init_callbacks();
  1008.     }
  1009.     my $rv;
  1010.     eval {
  1011.         $rv = $self->_processXIncludes($doc || " ", $options);
  1012.     };
  1013.     my $err = $@;
  1014.     if ( $self->{_State_} != 1 ) {
  1015.         $self->_cleanup_callbacks();
  1016.     }
  1017.  
  1018.     if ( $err ) {
  1019.         chomp $err unless ref $err;
  1020.         croak $err;
  1021.     }
  1022.     return $rv;
  1023. }
  1024.  
  1025. # perl style
  1026. sub process_xincludes {
  1027.     my $self = shift;
  1028.     my $doc = shift;
  1029.     my $opts = shift;
  1030.     my $options = $self->_parser_options($opts);
  1031.  
  1032.     my $rv;
  1033.     $self->_init_callbacks();
  1034.     eval {
  1035.         $rv = $self->_processXIncludes($doc || " ", $options);
  1036.     };
  1037.     my $err = $@;
  1038.     $self->_cleanup_callbacks();
  1039.     if ( $err ) {
  1040.         chomp $err unless ref $err;
  1041.         croak $@;
  1042.     }
  1043.     return $rv;
  1044. }
  1045.  
  1046. #-------------------------------------------------------------------------#
  1047. # HTML parsing functions                                                  #
  1048. #-------------------------------------------------------------------------#
  1049.  
  1050. sub _html_options {
  1051.   my ($self,$opts)=@_;
  1052.   $opts = {} unless ref $opts;
  1053.   #  return (undef,undef) unless ref $opts;
  1054.   my $flags = 0;
  1055.   $flags |=     1 if exists $opts->{recover} ? $opts->{recover} : $self->recover;
  1056.   $flags |=    32 if $opts->{suppress_errors};
  1057.   $flags |=    64 if $opts->{suppress_warnings};
  1058.   $flags |=   128 if exists $opts->{pedantic_parser} ? $opts->{pedantic_parser} : $self->pedantic_parser;
  1059.   $flags |=   256 if exists $opts->{no_blanks} ? $opts->{no_blanks} : !$self->keep_blanks;
  1060.   $flags |=  2048 if exists $opts->{no_network} ? $opts->{no_network} : !$self->no_network;
  1061.   $flags |= 16384 if  $opts->{no_cdata};
  1062.   $flags |= 65536 if $opts->{compact}; # compact small text nodes; no modification
  1063.                                          # of the tree allowed afterwards
  1064.                                          # (WILL possibly CRASH IF YOU try to MODIFY THE TREE)
  1065.   $flags |= 524288 if $opts->{huge}; # relax any hardcoded limit from the parser
  1066.   $flags |= 1048576 if $opts->{oldsax}; # parse using SAX2 interface from before 2.7.0
  1067.  
  1068.   return ($opts->{URI},$opts->{encoding},$flags);
  1069. }
  1070.  
  1071. sub parse_html_string {
  1072.     my ($self,$str,$opts) = @_;
  1073.     croak("parse_html_string is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
  1074.     croak("parse already in progress") if $self->{_State_};
  1075.  
  1076.     unless ( defined $str and length $str ) {
  1077.         croak("Empty String");
  1078.     }
  1079.     $self->{_State_} = 1;
  1080.     my $result;
  1081.  
  1082.     $self->_init_callbacks();
  1083.     eval { 
  1084.       $result = $self->_parse_html_string( $str,
  1085.                        $self->_html_options($opts)
  1086.                       ); 
  1087.     };
  1088.     my $err = $@;
  1089.     $self->{_State_} = 0;
  1090.     if ($err) {
  1091.       chomp $err unless ref $err;
  1092.       $self->_cleanup_callbacks();
  1093.       croak $err;
  1094.     }
  1095.  
  1096.     $self->_cleanup_callbacks();
  1097.  
  1098.     return $result;
  1099. }
  1100.  
  1101. sub parse_html_file {
  1102.     my ($self,$file,$opts) = @_;
  1103.     croak("parse_html_file is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
  1104.     croak("parse already in progress") if $self->{_State_};
  1105.     $self->{_State_} = 1;
  1106.     my $result;
  1107.  
  1108.     $self->_init_callbacks();
  1109.     eval { $result = $self->_parse_html_file($file,
  1110.                          $self->_html_options($opts)
  1111.                         ); };
  1112.     my $err = $@;
  1113.     $self->{_State_} = 0;
  1114.     if ($err) {
  1115.       chomp $err unless ref $err;
  1116.       $self->_cleanup_callbacks();
  1117.       croak $err;
  1118.     }
  1119.     
  1120.     $self->_cleanup_callbacks();
  1121.  
  1122.     return $result;
  1123. }
  1124.  
  1125. sub parse_html_fh {
  1126.     my ($self,$fh,$opts) = @_;
  1127.     croak("parse_html_fh is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self;
  1128.     croak("parse already in progress") if $self->{_State_};
  1129.     $self->{_State_} = 1;
  1130.  
  1131.     my $result;
  1132.     $self->_init_callbacks();
  1133.     eval { $result = $self->_parse_html_fh( $fh, 
  1134.                         $self->_html_options($opts)
  1135.                        ); };
  1136.     my $err = $@;
  1137.     $self->{_State_} = 0;
  1138.     if ($err) {
  1139.       chomp $err unless ref $err;
  1140.       $self->_cleanup_callbacks();
  1141.       croak $err;
  1142.     }
  1143.     $self->_cleanup_callbacks();
  1144.  
  1145.     return $result;
  1146. }
  1147.  
  1148. #-------------------------------------------------------------------------#
  1149. # push parser interface                                                   #
  1150. #-------------------------------------------------------------------------#
  1151. sub init_push {
  1152.     my $self = shift;
  1153.  
  1154.     if ( defined $self->{CONTEXT} ) {
  1155.         delete $self->{CONTEXT};
  1156.     }
  1157.  
  1158.     if ( defined $self->{SAX} ) {
  1159.         $self->{CONTEXT} = $self->_start_push(1);
  1160.     }
  1161.     else {
  1162.         $self->{CONTEXT} = $self->_start_push(0);
  1163.     }
  1164. }
  1165.  
  1166. sub push {
  1167.     my $self = shift;
  1168.  
  1169.     $self->_init_callbacks();
  1170.     
  1171.     if ( not defined $self->{CONTEXT} ) {
  1172.         $self->init_push();
  1173.     }
  1174.  
  1175.     eval {
  1176.         foreach ( @_ ) {
  1177.             $self->_push( $self->{CONTEXT}, $_ );
  1178.         }
  1179.     };
  1180.     my $err = $@;
  1181.     $self->_cleanup_callbacks();
  1182.     if ( $err ) {
  1183.         chomp $err unless ref $err;
  1184.         croak $err;
  1185.     }
  1186. }
  1187.  
  1188. # this function should be promoted!
  1189. # the reason is because libxml2 uses xmlParseChunk() for this purpose!
  1190. sub parse_chunk {
  1191.     my $self = shift;
  1192.     my $chunk = shift;
  1193.     my $terminate = shift;
  1194.  
  1195.     if ( not defined $self->{CONTEXT} ) {
  1196.         $self->init_push();
  1197.     }
  1198.  
  1199.     if ( defined $chunk and length $chunk ) {
  1200.         $self->_push( $self->{CONTEXT}, $chunk );
  1201.     }
  1202.  
  1203.     if ( $terminate ) {
  1204.         return $self->finish_push();
  1205.     }
  1206. }
  1207.  
  1208.  
  1209. sub finish_push {
  1210.     my $self = shift;
  1211.     my $restore = shift || 0;
  1212.     return undef unless defined $self->{CONTEXT};
  1213.  
  1214.     my $retval;
  1215.  
  1216.     if ( defined $self->{SAX} ) {
  1217.         eval {
  1218.             $self->_end_sax_push( $self->{CONTEXT} );
  1219.             $retval = $self->{HANDLER}->end_document( {} );
  1220.         };
  1221.     }
  1222.     else {
  1223.         eval { $retval = $self->_end_push( $self->{CONTEXT}, $restore ); };
  1224.     }
  1225.     my $err = $@;
  1226.     delete $self->{CONTEXT};
  1227.     if ( $err ) {
  1228.         chomp $err unless ref $err;
  1229.         croak( $err );
  1230.     }
  1231.     return $retval;
  1232. }
  1233.  
  1234. 1;
  1235.  
  1236. #-------------------------------------------------------------------------#
  1237. # XML::LibXML::Node Interface                                             #
  1238. #-------------------------------------------------------------------------#
  1239. package XML::LibXML::Node;
  1240.  
  1241. sub CLONE_SKIP {
  1242.   return $XML::LibXML::__threads_shared ? 0 : 1;
  1243. }
  1244.  
  1245. sub isSupported {
  1246.     my $self    = shift;
  1247.     my $feature = shift;
  1248.     return $self->can($feature) ? 1 : 0;
  1249. }
  1250.  
  1251. sub getChildNodes { my $self = shift; return $self->childNodes(); }
  1252.  
  1253. sub childNodes {
  1254.     my $self = shift;
  1255.     my @children = $self->_childNodes(0);
  1256.     return wantarray ? @children : XML::LibXML::NodeList->new_from_ref(\@children , 1);
  1257. }
  1258.  
  1259. sub nonBlankChildNodes {
  1260.     my $self = shift;
  1261.     my @children = $self->_childNodes(1);
  1262.     return wantarray ? @children : XML::LibXML::NodeList->new_from_ref(\@children , 1);
  1263. }
  1264.  
  1265. sub attributes {
  1266.     my $self = shift;
  1267.     my @attr = $self->_attributes();
  1268.     return wantarray ? @attr : XML::LibXML::NamedNodeMap->new( @attr );
  1269. }
  1270.  
  1271.  
  1272. sub findnodes {
  1273.     my ($node, $xpath) = @_;
  1274.     my @nodes = $node->_findnodes($xpath);
  1275.     if (wantarray) {
  1276.         return @nodes;
  1277.     }
  1278.     else {
  1279.         return XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
  1280.     }
  1281. }
  1282.  
  1283. sub exists {
  1284.     my ($node, $xpath) = @_;
  1285.     my (undef, $value) = $node->_find($xpath,1);
  1286.     return $value;
  1287. }
  1288.  
  1289. sub findvalue {
  1290.     my ($node, $xpath) = @_;
  1291.     my $res;
  1292.     $res = $node->find($xpath);
  1293.     return $res->to_literal->value;
  1294. }
  1295.  
  1296. sub findbool {
  1297.     my ($node, $xpath) = @_;
  1298.     my ($type, @params) = $node->_find($xpath,1);
  1299.     if ($type) {
  1300.         return $type->new(@params);
  1301.     }
  1302.     return undef;
  1303. }
  1304.  
  1305. sub find {
  1306.     my ($node, $xpath) = @_;
  1307.     my ($type, @params) = $node->_find($xpath,0);
  1308.     if ($type) {
  1309.         return $type->new(@params);
  1310.     }
  1311.     return undef;
  1312. }
  1313.  
  1314. sub setOwnerDocument {
  1315.     my ( $self, $doc ) = @_;
  1316.     $doc->adoptNode( $self );
  1317. }
  1318.  
  1319. sub toStringC14N {
  1320.     my ($self, $comments, $xpath, $xpc) = @_;
  1321.     return $self->_toStringC14N( $comments || 0,
  1322.                  (defined $xpath ? $xpath : undef),
  1323.                  0,
  1324.                  undef,
  1325.                  (defined $xpc ? $xpc : undef)
  1326.                 );
  1327. }
  1328. sub toStringEC14N {
  1329.     my ($self, $comments, $xpath, $xpc, $inc_prefix_list) = @_;
  1330.     unless (UNIVERSAL::isa($xpc,'XML::LibXML::XPathContext')) {
  1331.       if ($inc_prefix_list) {
  1332.     croak("toStringEC14N: 3rd argument is not an XML::LibXML::XPathContext");
  1333.       } else {
  1334.     $inc_prefix_list=$xpc;
  1335.     $xpc=undef;
  1336.       }
  1337.     }
  1338.     if (defined($inc_prefix_list) and !UNIVERSAL::isa($inc_prefix_list,'ARRAY')) {
  1339.       croak("toStringEC14N: inclusive_prefix_list must be undefined or ARRAY");
  1340.     }
  1341.     return $self->_toStringC14N( $comments || 0,
  1342.                  (defined $xpath ? $xpath : undef),
  1343.                  1,
  1344.                  (defined $inc_prefix_list ? $inc_prefix_list : undef),
  1345.                  (defined $xpc ? $xpc : undef)
  1346.                 );
  1347. }
  1348.  
  1349. *serialize_c14n = \&toStringC14N;
  1350. *serialize_exc_c14n = \&toStringEC14N;
  1351.  
  1352. 1;
  1353.  
  1354. #-------------------------------------------------------------------------#
  1355. # XML::LibXML::Document Interface                                         #
  1356. #-------------------------------------------------------------------------#
  1357. package XML::LibXML::Document;
  1358.  
  1359. use vars qw(@ISA);
  1360. @ISA = ('XML::LibXML::Node');
  1361.  
  1362. sub actualEncoding {
  1363.   my $doc = shift;
  1364.   my $enc = $doc->encoding;
  1365.   return (defined $enc and length $enc) ? $enc : 'UTF-8';
  1366. }
  1367.  
  1368. sub setDocumentElement {
  1369.     my $doc = shift;
  1370.     my $element = shift;
  1371.  
  1372.     my $oldelem = $doc->documentElement;
  1373.     if ( defined $oldelem ) {
  1374.         $doc->removeChild($oldelem);
  1375.     }
  1376.  
  1377.     $doc->_setDocumentElement($element);
  1378. }
  1379.  
  1380. sub toString {
  1381.     my $self = shift;
  1382.     my $flag = shift;
  1383.  
  1384.     my $retval = "";
  1385.  
  1386.     if ( defined $XML::LibXML::skipXMLDeclaration
  1387.          and $XML::LibXML::skipXMLDeclaration == 1 ) {
  1388.         foreach ( $self->childNodes ){
  1389.             next if $_->nodeType == XML::LibXML::XML_DTD_NODE()
  1390.                     and $XML::LibXML::skipDTD;
  1391.             $retval .= $_->toString;
  1392.         }
  1393.     }
  1394.     else {
  1395.         $flag ||= 0 unless defined $flag;
  1396.         $retval =  $self->_toString($flag);
  1397.     }
  1398.  
  1399.     return $retval;
  1400. }
  1401.  
  1402. sub serialize {
  1403.     my $self = shift;
  1404.     return $self->toString( @_ );
  1405. }
  1406.  
  1407. #-------------------------------------------------------------------------#
  1408. # bad style xinclude processing                                           #
  1409. #-------------------------------------------------------------------------#
  1410. sub process_xinclude {
  1411.     my $self = shift;
  1412.     my $opts = shift;
  1413.     XML::LibXML->new->processXIncludes( $self, $opts );
  1414. }
  1415.  
  1416. sub insertProcessingInstruction {
  1417.     my $self   = shift;
  1418.     my $target = shift;
  1419.     my $data   = shift;
  1420.  
  1421.     my $pi     = $self->createPI( $target, $data );
  1422.     my $root   = $self->documentElement;
  1423.  
  1424.     if ( defined $root ) {
  1425.         # this is actually not correct, but i guess it's what the user
  1426.         # intends
  1427.         $self->insertBefore( $pi, $root );
  1428.     }
  1429.     else {
  1430.         # if no documentElement was found we just append the PI
  1431.         $self->appendChild( $pi );
  1432.     }
  1433. }
  1434.  
  1435. sub insertPI {
  1436.     my $self = shift;
  1437.     $self->insertProcessingInstruction( @_ );
  1438. }
  1439.  
  1440. #-------------------------------------------------------------------------#
  1441. # DOM L3 Document functions.
  1442. # added after robins implicit feature requst
  1443. #-------------------------------------------------------------------------#
  1444. *getElementsByTagName = \&XML::LibXML::Element::getElementsByTagName;
  1445. *getElementsByTagNameNS = \&XML::LibXML::Element::getElementsByTagNameNS;
  1446. *getElementsByLocalName = \&XML::LibXML::Element::getElementsByLocalName;
  1447.  
  1448. 1;
  1449.  
  1450. #-------------------------------------------------------------------------#
  1451. # XML::LibXML::DocumentFragment Interface                                 #
  1452. #-------------------------------------------------------------------------#
  1453. package XML::LibXML::DocumentFragment;
  1454.  
  1455. use vars qw(@ISA);
  1456. @ISA = ('XML::LibXML::Node');
  1457.  
  1458. sub toString {
  1459.     my $self = shift;
  1460.     my $retval = "";
  1461.     if ( $self->hasChildNodes() ) {
  1462.         foreach my $n ( $self->childNodes() ) {
  1463.             $retval .= $n->toString(@_);
  1464.         }
  1465.     }
  1466.     return $retval;
  1467. }
  1468.  
  1469. *serialize = \&toString;
  1470.  
  1471. 1;
  1472.  
  1473. #-------------------------------------------------------------------------#
  1474. # XML::LibXML::Element Interface                                          #
  1475. #-------------------------------------------------------------------------#
  1476. package XML::LibXML::Element;
  1477.  
  1478. use vars qw(@ISA);
  1479. @ISA = ('XML::LibXML::Node');
  1480. use XML::LibXML qw(:ns :libxml);
  1481. use Carp;
  1482.  
  1483. sub setNamespace {
  1484.     my $self = shift;
  1485.     my $n = $self->nodeName;
  1486.     if ( $self->_setNamespace(@_) ){
  1487.         if ( scalar @_ < 3 || $_[2] == 1 ){
  1488.             $self->setNodeName( $n );
  1489.         }
  1490.         return 1;
  1491.     }
  1492.     return 0;
  1493. }
  1494.  
  1495. sub getAttribute {
  1496.     my $self = shift;
  1497.     my $name = $_[0];
  1498.     if ( $name =~ /^xmlns(?::|$)/ ) {
  1499.         # user wants to get a namespace ...
  1500.         (my $prefix = $name )=~s/^xmlns:?//;
  1501.     $self->_getNamespaceDeclURI($prefix);
  1502.     }
  1503.     else {
  1504.         $self->_getAttribute(@_);
  1505.     }
  1506. }
  1507.  
  1508. sub setAttribute {
  1509.     my ( $self, $name, $value ) = @_;
  1510.     if ( $name =~ /^xmlns(?::|$)/ ) {
  1511.       # user wants to set the special attribute for declaring XML namespace ...
  1512.  
  1513.       # this is fine but not exactly DOM conformant behavior, btw (according to DOM we should
  1514.       # probably declare an attribute which looks like XML namespace declaration
  1515.       # but isn't)
  1516.       (my $nsprefix = $name )=~s/^xmlns:?//;
  1517.       my $nn = $self->nodeName;
  1518.       if ( $nn =~ /^\Q${nsprefix}\E:/ ) {
  1519.     # the element has the same prefix
  1520.     $self->setNamespaceDeclURI($nsprefix,$value) ||
  1521.       $self->setNamespace($value,$nsprefix,1);
  1522.         ##
  1523.         ## We set the namespace here.
  1524.         ## This is helpful, as in:
  1525.         ##
  1526.         ## |  $e = XML::LibXML::Element->new('foo:bar');
  1527.         ## |  $e->setAttribute('xmlns:foo','http://yoyodine')
  1528.         ##
  1529.       }
  1530.       else {
  1531.     # just modify the namespace
  1532.     $self->setNamespaceDeclURI($nsprefix, $value) ||
  1533.       $self->setNamespace($value,$nsprefix,0);
  1534.       }
  1535.     }
  1536.     else {
  1537.         $self->_setAttribute($name, $value);
  1538.     }
  1539. }
  1540.  
  1541. sub getAttributeNS {
  1542.     my $self = shift;
  1543.     my ($nsURI, $name) = @_;
  1544.     croak("invalid attribute name") if !defined($name) or $name eq q{};
  1545.     if ( defined($nsURI) and $nsURI eq XML_XMLNS_NS ) {
  1546.     $self->_getNamespaceDeclURI($name eq 'xmlns' ? undef : $name);
  1547.     }
  1548.     else {
  1549.         $self->_getAttributeNS(@_);
  1550.     }
  1551. }
  1552.  
  1553. sub setAttributeNS {
  1554.   my ($self, $nsURI, $qname, $value)=@_;
  1555.   unless (defined $qname and length $qname) {
  1556.     croak("bad name");
  1557.   }
  1558.   if (defined($nsURI) and $nsURI eq XML_XMLNS_NS) {
  1559.     if ($qname !~ /^xmlns(?::|$)/) {
  1560.       croak("NAMESPACE ERROR: Namespace declarations must have the prefix 'xmlns'");
  1561.     }
  1562.     $self->setAttribute($qname,$value); # see implementation above
  1563.     return;
  1564.   }
  1565.   if ($qname=~/:/ and not (defined($nsURI) and length($nsURI))) {
  1566.     croak("NAMESPACE ERROR: Attribute without a prefix cannot be in a namespace");
  1567.   }
  1568.   if ($qname=~/^xmlns(?:$|:)/) {
  1569.     croak("NAMESPACE ERROR: 'xmlns' prefix and qualified-name are reserved for the namespace ".XML_XMLNS_NS);
  1570.   }
  1571.   if ($qname=~/^xml:/ and not (defined $nsURI and $nsURI eq XML_XML_NS)) {
  1572.     croak("NAMESPACE ERROR: 'xml' prefix is reserved for the namespace ".XML_XML_NS);
  1573.   }
  1574.   $self->_setAttributeNS( defined $nsURI ? $nsURI : undef, $qname, $value );
  1575. }
  1576.  
  1577. sub getElementsByTagName {
  1578.     my ( $node , $name ) = @_;
  1579.     my $xpath = $name eq '*' ? "descendant::*" : "descendant::*[name()='$name']";
  1580.     my @nodes = $node->_findnodes($xpath);
  1581.     return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
  1582. }
  1583.  
  1584. sub  getElementsByTagNameNS {
  1585.     my ( $node, $nsURI, $name ) = @_;
  1586.     my $xpath;
  1587.     if ( $name eq '*' ) {
  1588.       if ( $nsURI eq '*' ) {
  1589.     $xpath = "descendant::*";
  1590.       } else {
  1591.     $xpath = "descendant::*[namespace-uri()='$nsURI']";
  1592.       }
  1593.     } elsif ( $nsURI eq '*' ) {
  1594.       $xpath = "descendant::*[local-name()='$name']";
  1595.     } else {
  1596.       $xpath = "descendant::*[local-name()='$name' and namespace-uri()='$nsURI']";
  1597.     }
  1598.     my @nodes = $node->_findnodes($xpath);
  1599.     return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
  1600. }
  1601.  
  1602. sub getElementsByLocalName {
  1603.     my ( $node,$name ) = @_;
  1604.     my $xpath;
  1605.     if ($name eq '*') {
  1606.       $xpath = "descendant::*";
  1607.     } else {
  1608.       $xpath = "descendant::*[local-name()='$name']";
  1609.     }
  1610.     my @nodes = $node->_findnodes($xpath);
  1611.     return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
  1612. }
  1613.  
  1614. sub getChildrenByTagName {
  1615.     my ( $node, $name ) = @_;
  1616.     my @nodes;
  1617.     if ($name eq '*') {
  1618.       @nodes = grep { $_->nodeType == XML_ELEMENT_NODE() }
  1619.     $node->childNodes();
  1620.     } else {
  1621.       @nodes = grep { $_->nodeName eq $name } $node->childNodes();
  1622.     }
  1623.     return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
  1624. }
  1625.  
  1626. sub getChildrenByLocalName {
  1627.     my ( $node, $name ) = @_;
  1628.     # my @nodes;
  1629.     # if ($name eq '*') {
  1630.     #   @nodes = grep { $_->nodeType == XML_ELEMENT_NODE() }
  1631.     #     $node->childNodes();
  1632.     # } else {
  1633.     #   @nodes = grep { $_->nodeType == XML_ELEMENT_NODE() and
  1634.     #               $_->localName eq $name } $node->childNodes();
  1635.     # }
  1636.     # return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
  1637.     my @nodes = $node->_getChildrenByTagNameNS('*',$name);
  1638.     return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
  1639. }
  1640.  
  1641. sub getChildrenByTagNameNS {
  1642.     my ( $node, $nsURI, $name ) = @_;
  1643.     my @nodes = $node->_getChildrenByTagNameNS($nsURI,$name);
  1644.     return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1);
  1645. }
  1646.  
  1647. sub appendWellBalancedChunk {
  1648.     my ( $self, $chunk ) = @_;
  1649.  
  1650.     my $local_parser = XML::LibXML->new();
  1651.     my $frag = $local_parser->parse_xml_chunk( $chunk );
  1652.  
  1653.     $self->appendChild( $frag );
  1654. }
  1655.  
  1656. 1;
  1657.  
  1658. #-------------------------------------------------------------------------#
  1659. # XML::LibXML::Text Interface                                             #
  1660. #-------------------------------------------------------------------------#
  1661. package XML::LibXML::Text;
  1662.  
  1663. use vars qw(@ISA);
  1664. @ISA = ('XML::LibXML::Node');
  1665.  
  1666. sub attributes { return undef; }
  1667.  
  1668. sub deleteDataString {
  1669.     my $node = shift;
  1670.     my $string = shift;
  1671.     my $all    = shift;
  1672.     my $data = $node->nodeValue();
  1673.     $string =~ s/([\\\*\+\^\{\}\&\?\[\]\(\)\$\%\@])/\\$1/g;
  1674.     if ( $all ) {
  1675.         $data =~ s/$string//g;
  1676.     }
  1677.     else {
  1678.         $data =~ s/$string//;
  1679.     }
  1680.     $node->setData( $data );
  1681. }
  1682.  
  1683. sub replaceDataString {
  1684.     my ( $node, $left, $right,$all ) = @_;
  1685.  
  1686.     #ashure we exchange the strings and not expressions!
  1687.     $left  =~ s/([\\\*\+\^\{\}\&\?\[\]\(\)\$\%\@])/\\$1/g;
  1688.     my $datastr = $node->nodeValue();
  1689.     if ( $all ) {
  1690.         $datastr =~ s/$left/$right/g;
  1691.     }
  1692.     else{
  1693.         $datastr =~ s/$left/$right/;
  1694.     }
  1695.     $node->setData( $datastr );
  1696. }
  1697.  
  1698. sub replaceDataRegEx {
  1699.     my ( $node, $leftre, $rightre, $flags ) = @_;
  1700.     return unless defined $leftre;
  1701.     $rightre ||= "";
  1702.  
  1703.     my $datastr = $node->nodeValue();
  1704.     my $restr   = "s/" . $leftre . "/" . $rightre . "/";
  1705.     $restr .= $flags if defined $flags;
  1706.  
  1707.     eval '$datastr =~ '. $restr;
  1708.  
  1709.     $node->setData( $datastr );
  1710. }
  1711.  
  1712. 1;
  1713.  
  1714. package XML::LibXML::Comment;
  1715.  
  1716. use vars qw(@ISA);
  1717. @ISA = ('XML::LibXML::Text');
  1718.  
  1719. 1;
  1720.  
  1721. package XML::LibXML::CDATASection;
  1722.  
  1723. use vars qw(@ISA);
  1724. @ISA     = ('XML::LibXML::Text');
  1725.  
  1726. 1;
  1727.  
  1728. #-------------------------------------------------------------------------#
  1729. # XML::LibXML::Attribute Interface                                        #
  1730. #-------------------------------------------------------------------------#
  1731. package XML::LibXML::Attr;
  1732. use vars qw( @ISA ) ;
  1733. @ISA = ('XML::LibXML::Node') ;
  1734.  
  1735. sub setNamespace {
  1736.     my ($self,$href,$prefix) = @_;
  1737.     my $n = $self->nodeName;
  1738.     if ( $self->_setNamespace($href,$prefix) ) {
  1739.         $self->setNodeName($n);
  1740.         return 1;
  1741.     }
  1742.  
  1743.     return 0;
  1744. }
  1745.  
  1746. 1;
  1747.  
  1748. #-------------------------------------------------------------------------#
  1749. # XML::LibXML::Dtd Interface                                              #
  1750. #-------------------------------------------------------------------------#
  1751. # this is still under construction
  1752. #
  1753. package XML::LibXML::Dtd;
  1754. use vars qw( @ISA );
  1755. @ISA = ('XML::LibXML::Node');
  1756.  
  1757. # at least DESTROY and CLONE_SKIP must be inherited
  1758.  
  1759. 1;
  1760.  
  1761. #-------------------------------------------------------------------------#
  1762. # XML::LibXML::PI Interface                                               #
  1763. #-------------------------------------------------------------------------#
  1764. package XML::LibXML::PI;
  1765. use vars qw( @ISA );
  1766. @ISA = ('XML::LibXML::Node');
  1767.  
  1768. sub setData {
  1769.     my $pi = shift;
  1770.  
  1771.     my $string = "";
  1772.     if ( scalar @_ == 1 ) {
  1773.         $string = shift;
  1774.     }
  1775.     else {
  1776.         my %h = @_;
  1777.         $string = join " ", map {$_.'="'.$h{$_}.'"'} keys %h;
  1778.     }
  1779.  
  1780.     # the spec says any char but "?>" [17]
  1781.     $pi->_setData( $string ) unless  $string =~ /\?>/;
  1782. }
  1783.  
  1784. 1;
  1785.  
  1786. #-------------------------------------------------------------------------#
  1787. # XML::LibXML::Namespace Interface                                        #
  1788. #-------------------------------------------------------------------------#
  1789. package XML::LibXML::Namespace;
  1790.  
  1791. sub CLONE_SKIP { 1 }
  1792.  
  1793. # this is infact not a node!
  1794. sub prefix { return "xmlns"; }
  1795. sub getPrefix { return "xmlns"; }
  1796. sub getNamespaceURI { return "http://www.w3.org/2000/xmlns/" };
  1797.  
  1798. sub getNamespaces { return (); }
  1799.  
  1800. sub nodeName {
  1801.   my $self = shift;
  1802.   my $nsP  = $self->localname;
  1803.   return ( defined($nsP) && length($nsP) ) ? "xmlns:$nsP" : "xmlns";
  1804. }
  1805. sub name    { goto &nodeName }
  1806. sub getName { goto &nodeName }
  1807.  
  1808. sub isEqualNode {
  1809.     my ( $self, $ref ) = @_;
  1810.     if ( ref($ref) eq "XML::LibXML::Namespace" ) {
  1811.         return $self->_isEqual($ref);
  1812.     }
  1813.     return 0;
  1814. }
  1815.  
  1816. sub isSameNode {
  1817.     my ( $self, $ref ) = @_;
  1818.     if ( $$self == $$ref ){
  1819.         return 1;
  1820.     }
  1821.     return 0;
  1822. }
  1823.  
  1824. 1;
  1825.  
  1826. #-------------------------------------------------------------------------#
  1827. # XML::LibXML::NamedNodeMap Interface                                     #
  1828. #-------------------------------------------------------------------------#
  1829. package XML::LibXML::NamedNodeMap;
  1830.  
  1831. use XML::LibXML qw(:libxml);
  1832.  
  1833. sub CLONE_SKIP {
  1834.   return $XML::LibXML::__threads_shared ? 0 : 1;
  1835. }
  1836.  
  1837. sub new {
  1838.     my $class = shift;
  1839.     my $self = bless { Nodes => [@_] }, $class;
  1840.     $self->{NodeMap} = { map { $_->nodeName => $_ } @_ };
  1841.     return $self;
  1842. }
  1843.  
  1844. sub length     { return scalar( @{$_[0]->{Nodes}} ); }
  1845. sub nodes      { return $_[0]->{Nodes}; }
  1846. sub item       { $_[0]->{Nodes}->[$_[1]]; }
  1847.  
  1848. sub getNamedItem {
  1849.     my $self = shift;
  1850.     my $name = shift;
  1851.  
  1852.     return $self->{NodeMap}->{$name};
  1853. }
  1854.  
  1855. sub setNamedItem {
  1856.     my $self = shift;
  1857.     my $node = shift;
  1858.  
  1859.     my $retval;
  1860.     if ( defined $node ) {
  1861.         if ( scalar @{$self->{Nodes}} ) {
  1862.             my $name = $node->nodeName();
  1863.             if ( $node->nodeType() == XML_NAMESPACE_DECL ) {
  1864.                 return;
  1865.             }
  1866.             if ( defined $self->{NodeMap}->{$name} ) {
  1867.                 if ( $node->isSameNode( $self->{NodeMap}->{$name} ) ) {
  1868.                     return;
  1869.                 }
  1870.                 $retval = $self->{NodeMap}->{$name}->replaceNode( $node );
  1871.             }
  1872.             else {
  1873.                 $self->{Nodes}->[0]->addSibling($node);
  1874.             }
  1875.  
  1876.             $self->{NodeMap}->{$name} = $node;
  1877.             push @{$self->{Nodes}}, $node;
  1878.         }
  1879.         else {
  1880.             # not done yet
  1881.             # can this be properly be done???
  1882.             warn "not done yet\n";
  1883.         }
  1884.     }
  1885.     return $retval;
  1886. }
  1887.  
  1888. sub removeNamedItem {
  1889.     my $self = shift;
  1890.     my $name = shift;
  1891.     my $retval;
  1892.     if ( $name =~ /^xmlns/ ) {
  1893.         warn "not done yet\n";
  1894.     }
  1895.     elsif ( exists $self->{NodeMap}->{$name} ) {
  1896.         $retval = $self->{NodeMap}->{$name};
  1897.         $retval->unbindNode;
  1898.         delete $self->{NodeMap}->{$name};
  1899.         $self->{Nodes} = [grep {not($retval->isSameNode($_))} @{$self->{Nodes}}];
  1900.     }
  1901.  
  1902.     return $retval;
  1903. }
  1904.  
  1905. sub getNamedItemNS {
  1906.     my $self = shift;
  1907.     my $nsURI = shift;
  1908.     my $name = shift;
  1909.     return undef;
  1910. }
  1911.  
  1912. sub setNamedItemNS {
  1913.     my $self = shift;
  1914.     my $nsURI = shift;
  1915.     my $node = shift;
  1916.     return undef;
  1917. }
  1918.  
  1919. sub removeNamedItemNS {
  1920.     my $self = shift;
  1921.     my $nsURI = shift;
  1922.     my $name = shift;
  1923.     return undef;
  1924. }
  1925.  
  1926. 1;
  1927.  
  1928. package XML::LibXML::_SAXParser;
  1929.  
  1930. # this is pseudo class!!! and it will be removed as soon all functions
  1931. # moved to XS level
  1932.  
  1933. use XML::SAX::Exception;
  1934.  
  1935. sub CLONE_SKIP {
  1936.   return $XML::LibXML::__threads_shared ? 0 : 1;
  1937. }
  1938.  
  1939. # these functions will use SAX exceptions as soon i know how things really work
  1940. sub warning {
  1941.     my ( $parser, $message, $line, $col ) = @_;
  1942.     my $error = XML::SAX::Exception::Parse->new( LineNumber   => $line,
  1943.                                                  ColumnNumber => $col,
  1944.                                                  Message      => $message, );
  1945.     $parser->{HANDLER}->warning( $error );
  1946. }
  1947.  
  1948. sub error {
  1949.     my ( $parser, $message, $line, $col ) = @_;
  1950.  
  1951.     my $error = XML::SAX::Exception::Parse->new( LineNumber   => $line,
  1952.                                                  ColumnNumber => $col,
  1953.                                                  Message      => $message, );
  1954.     $parser->{HANDLER}->error( $error );
  1955. }
  1956.  
  1957. sub fatal_error {
  1958.     my ( $parser, $message, $line, $col ) = @_;
  1959.     my $error = XML::SAX::Exception::Parse->new( LineNumber   => $line,
  1960.                                                  ColumnNumber => $col,
  1961.                                                  Message      => $message, );
  1962.     $parser->{HANDLER}->fatal_error( $error );
  1963. }
  1964.  
  1965. 1;
  1966.  
  1967. package XML::LibXML::RelaxNG;
  1968.  
  1969. sub CLONE_SKIP { 1 }
  1970.  
  1971. sub new {
  1972.     my $class = shift;
  1973.     my %args = @_;
  1974.  
  1975.     my $self = undef;
  1976.     if ( defined $args{location} ) {
  1977.         $self = $class->parse_location( $args{location} );
  1978.     }
  1979.     elsif ( defined $args{string} ) {
  1980.         $self = $class->parse_buffer( $args{string} );
  1981.     }
  1982.     elsif ( defined $args{DOM} ) {
  1983.         $self = $class->parse_document( $args{DOM} );
  1984.     }
  1985.  
  1986.     return $self;
  1987. }
  1988.  
  1989. 1;
  1990.  
  1991. package XML::LibXML::Schema;
  1992.  
  1993. sub CLONE_SKIP { 1 }
  1994.  
  1995. sub new {
  1996.     my $class = shift;
  1997.     my %args = @_;
  1998.  
  1999.     my $self = undef;
  2000.     if ( defined $args{location} ) {
  2001.         $self = $class->parse_location( $args{location} );
  2002.     }
  2003.     elsif ( defined $args{string} ) {
  2004.         $self = $class->parse_buffer( $args{string} );
  2005.     }
  2006.  
  2007.     return $self;
  2008. }
  2009.  
  2010. 1;
  2011.  
  2012. #-------------------------------------------------------------------------#
  2013. # XML::LibXML::Pattern Interface                                          #
  2014. #-------------------------------------------------------------------------#
  2015.  
  2016. package XML::LibXML::Pattern;
  2017.  
  2018. sub CLONE_SKIP { 1 }
  2019.  
  2020. sub new {
  2021.   my $class = shift;
  2022.   my ($pattern,$ns_map)=@_;
  2023.   my $self = undef;
  2024.   
  2025.   unless (UNIVERSAL::can($class,'_compilePattern')) {
  2026.     croak("Cannot create XML::LibXML::Pattern - ".
  2027.       "your libxml2 is compiled without pattern support!");
  2028.   }
  2029.  
  2030.   if (ref($ns_map) eq 'HASH') {
  2031.     # translate prefix=>URL hash to a (URL,prefix) list
  2032.     $self = $class->_compilePattern($pattern,0,[reverse %$ns_map]);
  2033.   } else {
  2034.     $self = $class->_compilePattern($pattern,0);
  2035.   }
  2036.   return $self;
  2037. }
  2038.  
  2039. 1;
  2040.  
  2041. #-------------------------------------------------------------------------#
  2042. # XML::LibXML::RegExp Interface                                          #
  2043. #-------------------------------------------------------------------------#
  2044.  
  2045. package XML::LibXML::RegExp;
  2046.  
  2047. sub CLONE_SKIP { 1 }
  2048.  
  2049. sub new {
  2050.   my $class = shift;
  2051.   my ($regexp)=@_;
  2052.   unless (UNIVERSAL::can($class,'_compile')) {
  2053.     croak("Cannot create XML::LibXML::RegExp - ".
  2054.       "your libxml2 is compiled without regexp support!");
  2055.   }
  2056.   return $class->_compile($regexp);
  2057. }
  2058.  
  2059. 1;
  2060.  
  2061. #-------------------------------------------------------------------------#
  2062. # XML::LibXML::XPathExpression Interface                                  #
  2063. #-------------------------------------------------------------------------#
  2064.  
  2065. package XML::LibXML::XPathExpression;
  2066.  
  2067. sub CLONE_SKIP { 1 }
  2068.  
  2069. 1;
  2070.  
  2071.  
  2072. #-------------------------------------------------------------------------#
  2073. # XML::LibXML::InputCallback Interface                                    #
  2074. #-------------------------------------------------------------------------#
  2075. package XML::LibXML::InputCallback;
  2076.  
  2077. use vars qw($_CUR_CB @_GLOBAL_CALLBACKS @_CB_STACK);
  2078.  
  2079. BEGIN {
  2080.   $_CUR_CB = undef;
  2081.   @_GLOBAL_CALLBACKS = ();
  2082.   @_CB_STACK = ();
  2083. }
  2084.  
  2085. sub CLONE_SKIP {
  2086.   return $XML::LibXML::__threads_shared ? 0 : 1;
  2087. }
  2088.  
  2089. #-------------------------------------------------------------------------#
  2090. # global callbacks                                                        #
  2091. #-------------------------------------------------------------------------#
  2092. sub _callback_match {
  2093.     my $uri = shift;
  2094.     my $retval = 0;
  2095.  
  2096.     # loop through the callbacks and and find the first matching
  2097.     # The callbacks are stored in execution order (reverse stack order)
  2098.     # any new global callbacks are shifted to the callback stack.
  2099.     foreach my $cb ( @_GLOBAL_CALLBACKS ) {
  2100.  
  2101.         # callbacks have to return 1, 0 or undef, while 0 and undef 
  2102.         # are handled the same way. 
  2103.         # in fact, if callbacks return other values, the global match 
  2104.         # assumes silently that the callback failed.
  2105.  
  2106.         $retval = $cb->[0]->($uri);
  2107.  
  2108.         if ( defined $retval and $retval == 1 ) {
  2109.             # make the other callbacks use this callback
  2110.             $_CUR_CB = $cb;
  2111.             unshift @_CB_STACK, $cb; 
  2112.             last;
  2113.         }
  2114.     }
  2115.  
  2116.     return $retval;
  2117. }
  2118.  
  2119. sub _callback_open {
  2120.     my $uri = shift;
  2121.     my $retval = undef;
  2122.     
  2123.     # the open callback has to return a defined value. 
  2124.     # if one works on files this can be a file handle. But 
  2125.     # depending on the needs of the callback it also can be a 
  2126.     # database handle or a integer labeling a certain dataset.
  2127.  
  2128.     if ( defined $_CUR_CB ) {
  2129.         $retval = $_CUR_CB->[1]->( $uri );
  2130.         
  2131.         # reset the callbacks, if one callback cannot open an uri
  2132.         if ( not defined $retval or $retval == 0 ) {
  2133.             shift @_CB_STACK;
  2134.             $_CUR_CB = $_CB_STACK[0];
  2135.         }
  2136.     }
  2137.     
  2138.     return $retval;
  2139. }
  2140.  
  2141. sub _callback_read {
  2142.     my $fh = shift;
  2143.     my $buflen = shift;
  2144.  
  2145.     my $retval = undef;
  2146.  
  2147.     if ( defined $_CUR_CB ) {
  2148.         $retval = $_CUR_CB->[2]->( $fh, $buflen );
  2149.     }
  2150.  
  2151.     return $retval;
  2152. }
  2153.  
  2154. sub _callback_close {
  2155.     my $fh = shift;
  2156.     my $retval = 0;
  2157.     
  2158.     if ( defined $_CUR_CB ) {
  2159.         $retval = $_CUR_CB->[3]->( $fh );
  2160.         shift @_CB_STACK;
  2161.         $_CUR_CB = $_CB_STACK[0];
  2162.     }
  2163.  
  2164.     return $retval;
  2165. }
  2166.  
  2167. #-------------------------------------------------------------------------#
  2168. # member functions and methods                                            #
  2169. #-------------------------------------------------------------------------#
  2170.  
  2171. sub new {
  2172.     my $CLASS = shift;
  2173.     return bless {'_CALLBACKS' => []}, $CLASS;
  2174. }
  2175.  
  2176. # add a callback set to the callback stack
  2177. # synopsis: $icb->register_callbacks( [$match_cb, $open_cb, $read_cb, $close_cb] );
  2178. sub register_callbacks {
  2179.     my $self = shift;
  2180.     my $cbset = shift;
  2181.     
  2182.     # test if callback set is complete
  2183.     if ( ref $cbset eq "ARRAY" and scalar( @$cbset ) == 4 ) {
  2184.         unshift @{$self->{_CALLBACKS}}, $cbset;
  2185.     }
  2186. }
  2187.  
  2188. # remove a callback set to the callback stack
  2189. # if a callback set is passed, this function will check for the match function
  2190. sub unregister_callbacks {
  2191.     my $self = shift;
  2192.     my $cbset = shift;
  2193.     if ( ref $cbset eq "ARRAY" and scalar( @$cbset ) == 4 ) {
  2194.         $self->{_CALLBACKS} = [grep { $_->[0] != $cbset->[0] } @{$self->{_CALLBACKS}}];
  2195.     }
  2196.     else {
  2197.         shift @{$self->{_CALLBACKS}};
  2198.     }
  2199. }
  2200.  
  2201. # make libxml2 use the callbacks 
  2202. sub init_callbacks {
  2203.     my $self = shift;
  2204.  
  2205.     $_CUR_CB           = undef;
  2206.     @_CB_STACK         = ();
  2207.  
  2208.     @_GLOBAL_CALLBACKS = @{ $self->{_CALLBACKS} };
  2209.     
  2210.     if ( defined $XML::LibXML::match_cb and 
  2211.          defined $XML::LibXML::open_cb  and 
  2212.          defined $XML::LibXML::read_cb  and 
  2213.          defined $XML::LibXML::close_cb ) {
  2214.         push @_GLOBAL_CALLBACKS, [$XML::LibXML::match_cb,
  2215.                                   $XML::LibXML::open_cb,
  2216.                                   $XML::LibXML::read_cb,
  2217.                                   $XML::LibXML::close_cb];
  2218.     }
  2219.  
  2220.     $self->lib_init_callbacks();
  2221. }
  2222.  
  2223. # reset libxml2's callbacks
  2224. sub cleanup_callbacks {
  2225.     my $self = shift;
  2226.     
  2227.     $_CUR_CB           = undef;
  2228.     @_GLOBAL_CALLBACKS = ();
  2229.     @_CB_STACK         = ();
  2230.  
  2231.     $self->lib_cleanup_callbacks();
  2232. }
  2233.  
  2234. $XML::LibXML::__loaded=1;
  2235.  
  2236. 1;
  2237.  
  2238. __END__
  2239.